home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-11
/
gensmall.zip
/
_SYSPICK.TEM
next >
Wrap
Text File
|
1993-01-04
|
21KB
|
674 lines
*****************************************************************************
*****************************************************************************
** These are the modifications to the template which allows the correct
** parameters to be passed to VARFUNS.TLB's function:
** build_row_display_xpr.
** The modification was necessary for long strings which must be split for
** Clipper users, which must contain the correct quotation marks. This
** Modification uses a variable "rowdispxpr_Q" to build the row expression
** parameter which is placed in quotes and passed to PICKDRVR.PRG.
** This only affects long "rowdispxpr's" which require splitting.
** Modification 1): Line 54
** Modification 2): Line 138
** Modification 3): Line 360
** (John McCarvel 6-13-89)
******************************************************************************
******************************************************************************
<<title Internal pick-window generator for SMALLSYS. Do not run>>
<<uicode>>
if type(_insys_) = "U"
gen_error(;
"_SYSPICK.TEM is part of the SMALLSYS system. It cannot be run separately.")
endif
private pickbox ** the box we're generating a pick for
private dad
private i
**
** LINKs: set up depending on defs found in pickbox slots
**
private picklinks ** all links
private plink ** temp
private helpl ** help link
private displ ** display link
private appendl ** append link
private editl ** edit link
private deletel ** delete link
private codename ** temp
private codetype
private linkrunner ** used in set_next_link()
private link1
**
** privates used in generating pick list code
**
private field1 ** the first field in window's item row
private dbf1 ** field1's parent DBF
private firstrow, lastrow ** 1st and last rows used by picklist
private firstcol, lastcol
private rowdispxpr ** the row display expression
private rowdispxpr_Q ** the row display expression w. quotes
private autoseek ** generate autoseek code? flag
private setproc ** SET PROC needed? flag
private usedriver ** use picklist driver? flag
** get name of dad (calling module(s)/proc(s)
dad = link_dadname(picklink)
** get name,type of this module/proc
codename = link_codename(picklink)
codetype = link_codetype(picklink)
** get actual pickbox object from link line
pickbox = grab_box(link_objname(picklink))
** if we're a proc, set this
if codetype = "PROC"
active_procfile = file
endif
**
** set up links, if any
**
appendl = ""
editl = ""
deletel = ""
helpl = ""
displ = ""
picklinks = array('C', 32)
linkrunner = array('N',2)
linkrunner[1] = 1
linkrunner[2] = 1
picklinks[1] = set_next_link(pickbox, codename)
for i = 2 to len(picklinks)
exit when empty(picklinks[i-1])
switch link_act(picklinks[i-1])
case "APPEND"
appendl = picklinks[i-1]
case "EDIT"
editl = picklinks[i-1]
case "DELETE"
deletel = picklinks[i-1]
case "HELP"
helpl = picklinks[i-1]
case "DISPLAY"
displ = picklinks[i-1]
endsw
picklinks[i] = set_next_link(pickbox, codename)
next
** force inline display link if none specified
if empty(displ)
displ = digest_link(codename, "DISPLAY {pickbox.name} ~ INLINE", ;
"DISPLAY", "INLINE")
endif
** if we're a module but links (just set) have implied a procfile, flag it
if codetype = "MODULE" .and. (.not. empty(active_procfile))
setproc = .T. ** flag set proc needed
endif
** until I find out how to get the length of an array in FoxBASE 2.x,
** only Clipper Summer 87 can use the generic picklist driver
if Summer87()
usedriver = ask_for_yn(";
Use generic pick list driver for {codename} (slower but smaller)?")
else
usedriver = .f.
endif
if usedriver
add_link_to_sys("PICKDRVR ~ ~ MODULE:{gendir}PICKDRVR.PRG {codename}")
endif
**
** set up pick list privates defined above
**
field1 = first_field_in_box(pickbox)
dbf1 = field1.dbf
firstrow = field1.row
lastrow = last_empty_row_after(pickbox, field1.row, field1.col)
firstcol = pickbox.left + iif(pickbox.outline.type,1,0)
lastcol = pickbox.right - iif(pickbox.outline.type,1,0)
rowdispxpr = build_row_display_xpr(pickbox, firstrow)
rowdispxpr_Q = build_row_display_xpr(pickbox, firstrow, .t.) && within quotes
autoseek = use_autoseek(pickbox)
**
**
****************************************
*** generate comment header ***
****************************************
?
? replicate('*',76)
? "**{space(72)}**"
if codetype = "PROC"
? banrline("Procedure {link_codename(picklink)}")
else
? banrline("{link_codename(picklink)} (file {link_codefile(picklink)})")
endif
if .not. empty(dad)
? banrline("Called from {dad}")
else
? banrline("Top-level module")
endif
? "**{space(72)}**"
? banrline("Generated from box '{link_objname(picklink)}' in .WW file '{wwfile}'")
? "**{space(72)}**"
? banrline("Pick list into database {dbf1.name}.")
if len(dbf1.indexes) > 0
? banrline("Indexed on {dbf1.indexes[1].name} ('{dbf1.indexes[1].expr}')")
endif
if usedriver
? banrline("Uses generic driver PICKDRVR.PRG")
endif
link1 = .f.
for i = 1 to len(picklinks)
exit when empty(picklinks[i])
if .not. link1
? "**{space(72)}**"
? banrline("Other actions from this {codetype}:")
? "**{space(72)}**"
link1 = .t.
endif
plink = picklinks[i]
? banrline(" {link_act(plink)}: {link_codename(plink)} ({link_codetype(plink)})")
next
? "**{space(72)}**"
for i = 1 to len(picklinks)
exit when empty(picklinks[i])
if link_codetype(picklinks[i]) = "PROC"
if active_procfile <> file
? banrline("Procedures defined in {active_procfile}")
else
? banrline("Procedures defined in this file.")
endif
exit
endif
next
? replicate('*',76)
if codetype = "PROC"
?
? "PROCEDURE {link_codename(picklink)}"
endif
?
****************************************
*** end of comment header gen, ***
*** lots of literal code starts here ***
****************************************
<<enduicode>>
<<if .not. empty(dad) ** not top system module>>
PARAM retval && passback success var
<<else>>
PRIVATE retval
<<endif>>
PRIVATE ok && passback var for append and/or delete
PRIVATE t, l, b, r && pickbox coordinates
PRIVATE locolor, hicolor && colors
<<if usedriver>>
PRIVATE hotkeys && keys to force driver exit
PRIVATE startrow && row offset into list, pass thru driver
<<else>>
PRIVATE currow, thisrow && row save variables
PRIVATE drows, dcols && # display rows, # display columns
PRIVATE rec1, recN && recno() save variables
PRIVATE saverec, toprec && ditto
PRIVATE keyhit && keyhit holder
PRIVATE redisp, slide && redisplay flags
PRIVATE trash && self-explanatory, haha
<<if autoseek>>
PRIVATE seekbuf && autoseek buffer
<<endif>>
<<if Clipper() .or. Fox2()>>
PRIVATE {pop_buf_name(pickbox)} && screen save buffer
<<endif>>
<<endif>>
<<if empty(dad) ** top (first) module>>
<<env_setup()>>
CLEAR
* global data directories
dbfpath = "{dbfdir}"
indexpath = "{ndxdir}"
<<init_all_dbfs("dbfpath","indexpath",.t.)>>
<<endif>>
SET DELETED ON && for picklist
<<if setproc ** do a set proc?>>
<<if Clipper()>>
SET PROC TO {stripdir(striptag(active_procfile))}
<<else>>
SET PROC TO {active_procfile}
<<endif>>
<<endif>>
<<uicode>>
** generate commented EXTERNAL line for Clipper
if Clipper()
private externstart
externstart = .F.
for i = 1 to len(picklinks)
plink = picklinks[i]
exit when empty(plink)
if (.not. empty(plink)) .and. ;
link_codetype(plink) = "MODULE"
if .not. externstart
? "** Uncomment following line to declare modules EXTERNAL (i.e. don't compile"
? "** into {striptag(file)}.OBJ, but specify them to the linker)"
? "** EXTERNAL "
externstart = .T.
else
?? ", "
endif
?? link_codename(plink)
endif
next
endif
<<enduicode>>
<<if link_codetype(displ) = "INLINE">>
<<pop_box(pickbox)>>
<<else>>
<<call_save_screen(pickbox, pop_buf_name(pickbox))>>
DO {link_codename(displ)}
<<endif>>
hicolor = "{field1.color}"
locolor = "{pickbox.contents.color}"
<<if .not. usedriver>>
t = {firstrow}
l = {firstcol}
b = {lastrow}
r = {lastcol}
saverec = recno() && in case this was important
GO TOP && snag some important recno()s
rec1 = recno()
GO BOTTOM
recN = recno()
GO saverec && back to where we started
<<if autoseek>>
seekbuf = "" && init seek buffer
<<endif>>
drows = b-t+1 && number of displayed rows
dcols = r-l+1 && number of displayed columns
currow = t && current row at top of pickbox
redisp = -1 && initial display, leave hilite at top
slide = 0 && no initial slide
<<do case>>
<<case Clipper()>>
SET CURSOR OFF
<<case Fox2()>>
?? sys(2002) && cursor off
<<endcase>>
<<endif>>
<<uicode>>
if usedriver
for i = 1 to len(picklinks)-1
exit when empty(picklinks[i])
next
if Clipper()
?"DECLARE hotkeys[{i-1}] && hot key array for driver"
for i = 1 to len(picklinks)-1
exit when empty(picklinks[i])
?"hotkeys[{i}] = {link_key(picklinks[i])}"
next
else
?"DIMENSION hotkeys({i-1}) && hot key array for driver"
for i = 1 to len(picklinks)-1
exit when empty(picklinks[i])
?"STORE {link_key(picklinks[i])} TO hotkeys({i})"
next
endif
endif
<<enduicode>>
SET COLOR TO &locolor, &hicolor
ok = .F. && initialize passback var
startrow = 0 && first startrow is 0 (top of list)
DO WHILE .T.
<<if usedriver>>
keyhit = 0
DO PICKDRVR WITH ;
{firstrow}, {firstcol}, {lastrow}, {lastcol}, ;
'{rowdispxpr_Q}', ; && enclosed in quotes
"{pickbox.contents.color}", "{field1.color}", ;
{iif(autoseek,".T.", ".F.")}, ;
hotkeys, ;
keyhit, ;
startrow
<<else>>
DO CASE && display stuff from flags set below
<<do case ** hardware scroll, if flavor supports it>>
<<case Clipper()>>
CASE slide <> 0 && slide 1 row up or down
scroll(t, l, b, r, slide) && do hardware scroll
currow = iif(slide <0, t, b) && set currow for hilite below
slide = 0 && unset slide
<<case Fox2()>>
CASE slide <> 0 && slide 1 row up or down
SCROLL t, l, b, r, slide && do hardware scroll
currow = iif(slide <0, t, b) && set currow for hilite below
slide = 0 && unset slide
<<endcase>>
CASE redisp < 0 && redisplay, leaving current rec at top
toprec = recno() && save top rec
thisrow = t && display rows from t to b
DO WHILE thisrow <= b .AND. .NOT. eof()
sprint(thisrow, l, ;
{rowdispxpr} )
SKIP
thisrow = thisrow +1
ENDDO
DO WHILE thisrow <= b && in case empty rows after eof()
sprint(thisrow, l, space(dcols) )
thisrow = thisrow +1
ENDDO
GO toprec && go back to top
thisrow = redisp
currow = t && set currow for hilite later
DO WHILE thisrow < -1
SKIP
currow = currow +1
thisrow = thisrow +1
ENDDO
redisp = 0 && unset redisp
CASE redisp > 0 && redisplay, leaving current rec at bot
thisrow = t && display rows from t to b
DO WHILE .NOT. eof() .AND. thisrow <= b
sprint(thisrow, l, ;
{rowdispxpr} )
SKIP
thisrow = thisrow +1
ENDDO
DO WHILE thisrow <= b && in case empty rows after eof()
sprint(thisrow, l, space(dcols) )
thisrow = thisrow +1
ENDDO
thisrow = thisrow -1
SKIP -1
DO WHILE redisp > 1
thisrow = thisrow -1 && set currow for hilite, below
redisp = redisp -1
ENDDO
currow = thisrow
redisp = 0
ENDCASE
sprint(currow, l, ;
{rowdispxpr}, hicolor ) && hilite current item
keyhit = inkey(0) && get keyhit
CLEAR TYPEAHEAD && need all the speed we can get
<<endif>>
DO CASE && key hit action loop
<<uicode>>
** the links
for i = 1 to len(picklinks)
plink = picklinks[i]
exit when empty(plink)
switch link_act(plink)
case "EDIT" ** edit link
<<enduicode>>
CASE keyhit = {link_key(plink)}
DO {link_codename(plink)} WITH ok && edit current record
SET COLOR TO &locolor, &hicolor && just in case
<<if .not. usedriver>>
IF ok
SKIP -(currow-t)
redisp = -1-(currow-t) && redisp
ENDIF
<<endif>>
<<uicode>>
case "APPEND" ** append link
<<enduicode>>
CASE keyhit = {link_key(plink)}
DO {link_codename(plink)} WITH ok
SET COLOR TO &locolor, &hicolor && just in case
<<if .not. usedriver>>
IF ok && we really appended
SKIP -(currow-t)
redisp = -1-(currow-t) && redisp
ENDIF
<<endif>>
<<uicode>>
case "DELETE" ** delete link
<<enduicode>>
CASE keyhit = {link_key(plink)}
<<if link_codetype(plink) = "INLINE" ** inline, generate it here>>
<<q_indent = 6>>
<<gen_confirm(plink)>>
<<q_indent = 0>>
hicolor = "{field1.color}"
locolor = "{pickbox.contents.color}"
<<else ** proc/module, just call it here>>
DO {link_codename(plink)} WITH ok && delete current record
<<endif>>
<<if .not. usedriver>>
IF ok && we actually deleted it
SKIP -(currow-t)
redisp = -1-(currow-t) && redisp
ENDIF
<<endif>>
SET COLOR TO &locolor, &hicolor && just in case
<<uicode>>
case "HELP" ** help link
<<enduicode>>
CASE keyhit = {link_key(plink)}
<<if link_codetype(plink) = "INLINE" ** inline, generate it here>>
<<q_indent = 6>>
<<gen_disphit(plink)>>
<<q_indent = 0>>
hicolor = "{field1.color}"
locolor = "{pickbox.contents.color}"
SET COLOR TO &locolor, &hicolor && just in case
<<else ** proc/module, just call it here>>
DO {link_codename(plink)} && pop help
SET COLOR TO &locolor, &hicolor && just in case
<<endif>>
<<uicode>>
otherwise ** some other kinda link, menu prolly
<<enduicode>>
CASE keyhit = {link_key(plink)}
DO {link_codename(plink)} WITH ok
SET COLOR TO &locolor, &hicolor && just in case
<<if .not. usedriver>>
IF ok && we really appended
SKIP -(currow-t)
redisp = -1-(currow-t) && redisp
ENDIF
<<endif>>
<<uicode>>
endsw
next
<<enduicode>>
CASE keyhit = 13 && car. ret. -- recno() is already set
retval = .T.
EXIT
CASE keyhit = 27 && escape
retval = .F.
EXIT
<<if .not. usedriver>>
CASE keyhit = 5 && up
IF recno() = rec1 && at top?
?? chr(7)
ELSE
&& unhilite current selection
sprint(currow, l, ;
{rowdispxpr}, locolor)
SKIP -1 && decrement selected record
IF currow > t && not the top displayed row
currow = currow - 1 && just decrement
ELSE && top displayed row
<<if Clipper() .or. Fox2() ** hardware scroll if possible>>
slide = -1 && set slide flag
<<else ** otherwise plain old redisplay>>
redisp = -1 && redisplay, 1 up from current
<<endif ** end of hardware scroll>>
ENDIF
ENDIF
CASE keyhit = 24 && down
IF recno() = recN && at bottom of file?
?? chr(7)
ELSE
&& unhilite current selection
sprint(currow, l, ;
{rowdispxpr}, locolor )
SKIP && increment selected record
IF currow < b && not the last displayed row
currow = currow + 1 && just increment
ELSE && bottom displayed row
<<if Clipper() .or. Fox2() ** hardware scroll if possible>>
slide = 1 && set slide flag
<<else ** otherwise plain old redisplay>>
SKIP 2-drows
redisp = 1 && redisplay, 1 up from current
<<endif ** end of hardware scroll>>
ENDIF
ENDIF
CASE keyhit = 18 && page up
SKIP t - currow - drows && skip to top of prec page
IF bof() && beep if at top
?? chr(7)
ENDIF
redisp = -1 && redisp, leaving hilite at top
CASE keyhit = 3 && page down
SKIP t -currow +(2*drows) -1 && skip to there we want bot. of new page
IF eof() && ran out of file
?? chr(7)
SKIP -drows && skip to 1 page above eof()
redisp = 1 && redisp, leaving hilite at bottom
ELSE && ok
SKIP 1-drows && skip to 1 page above eof()
redisp = -1 && redisp, leaving hilite at top
ENDIF
CASE keyhit = 1 && home, easy
GO TOP
redisp = -1
CASE keyhit = 6 && end, pretty easy
GO BOTTOM
SKIP 1-drows
redisp = 1
<<if autoseek>>
CASE keyhit > 32 .AND. keyhit < 127 && printable char, try seeking
saverec = recno() && save current record pos
&& add letter to seek buffer
seekbuf = seekbuf + upper(chr(keyhit))
SEEK seekbuf && give it a shot
IF eof() && naah, beep & retreat
?? chr(7)
seekbuf = substr(seekbuf,1,len(seekbuf)-1)
GO saverec
ELSE
SKIP -(currow-t)
redisp = -1-(currow-t) && redisp
ENDIF
CASE keyhit = 8 && backspace
<<if Clipper()>>
IF empty(seekbuf) && seek buffer's empty
<<else>>
IF len(trim(seekbuf)) = 0 && seek buffer's empty
<<endif>>
?? chr(7)
LOOP
ENDIF
seekbuf = substr(seekbuf,1,len(seekbuf)-1)
SEEK seekbuf && we know it's here
redisp = -1
<<endif>>
<<endif>>
ENDCASE
ENDDO
<<do case>>
<<case Clipper()>>
SET CURSOR ON
<<case Fox2()>>
?? sys(2002,1) && cursor on
<<endcase>>
<<if Clipper() .or. Fox2()>>
<<unpop_box(pickbox)>>
<<endif>>
<<if .not. empty(deletel) ** we turned delete on, turn it off>>
SET DELETED OFF
<<endif>>
<<if empty(dad) ** top module, shut things off>>
CLOSE DATABASES && shut everything down
<<endif>>
<<if setproc>>
<<if active_procfile <> file>>
SET PROC TO
<<endif>>
<<endif>>
RETURN
<<uicode>>
**
** reset active_procfile
**
if setproc ** if we opened the proc file in here, close it
active_procfile = ""
endif
<<enduicode>>